home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / MCL Utilities / pict-dialog-items.lisp < prev    next >
Encoding:
Text File  |  1990-08-17  |  32.7 KB  |  817 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;  pict-dialog-items.lisp
  3. ;;
  4. ;;  Copyright 1990 by Ruben Kleiman for Apple Computer, Inc.
  5. ;;  Advanced Technology Group
  6. ;;
  7. ;;  This file defines pict-dialog-items which work like PICT buttons.
  8. ;;  *pict-dialog-item* can be copy and pasted to/from the clipboard.
  9. ;;  This permits you to directly import and export a PICT from
  10. ;;  another MultiFinder application.
  11. ;;
  12. ;;  Functionality:
  13. ;;     A *pict-dialog-item* is associated with a PICT resource.  The
  14. ;;     PICT resource may be generated either by associating it with a PICT
  15. ;;     resource or by pasting from the clipboard.
  16. ;;
  17. ;;  See example at end of this file for the possible initial arguments
  18. ;;  that can be passed to ONEOF for *pict-dialog-item*.  The example
  19. ;;  shows how you can create a *pict-dialog-item* in a dialog
  20. ;;  and how you can associate it with a PICT resource from a resource file.
  21. ;;
  22. ;;  LAST MODIFIED: 5/14/90
  23. ;;
  24.  
  25. ;(require :resources)  ; This is needed for CONVERT-HANDLE-TO-RESOURCE and DELETE-RESOURCE functions
  26.  
  27.  
  28. (EVAL-WHEN (EVAL COMPILE)
  29.   (REQUIRE :TRAPS)
  30.   (REQUIRE :RECORDS))
  31.  
  32. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33. ;; *pict-dialog-item*
  34. ;;
  35. ;; the new class inherits from *dialog-item*
  36. ;;
  37. ;;   Initialization arguments include:
  38. ;;
  39. ;;      :my-pict-id
  40. ;;         associates the dialog item with a PICT resource ID.  The
  41. ;;         PICT will be loaded as necessary.  You should have opened
  42. ;;         the resource file in which this resource exists.
  43. ;;         DEFAULT:  no association
  44. ;;
  45. ;;      :zoom-factor
  46. ;;         establishes a zoom factor for drawing the PICT.  See
  47. ;;         comments in the function DIALOG-ITEM-DRAW below.
  48. ;;         DEFAULT: -1
  49. ;;
  50. ;;      :purgeable
  51. ;;         set to a non-nil value ensures that if the dialog item is
  52. ;;         associated with a resource, then it will be purgeable.
  53. ;;         Unpurgeable items improve performance in cases where memory is low;
  54. ;;         but purgeable items stretch memory by pushing the PICT to disk
  55. ;;         when it is not used AND memory is needed for something else.
  56. ;;         DEFAULT: NIL
  57. ;;
  58. ;;      :my-filename
  59. ;;         set to the resource file name with which this dialog item's PICT
  60. ;;         resource is associated.
  61. ;;
  62. ;;      :locked
  63. ;;         set to a non-nil value, it ensures that if the dialog item is
  64. ;;         associated with a resource, then it will be locked.
  65. ;;         This will improve performance, but should be used with great
  66. ;;         care because it can lead to fragmented memory.
  67. ;;         DEFAULT: NIL
  68. ;;
  69. (defobject *pict-dialog-item* *dialog-item*)
  70.  
  71.  
  72. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73. ;;
  74. ;;exist
  75. ;;
  76. ;;an added init-list option :pict-ID allows the caller specify which pict to use.
  77. ;;  the default is to use the :SCRAP pict
  78. ;;
  79.  
  80. (defobfun (exist *pict-dialog-item*) (init-list)
  81.   (let ((dialog (getf init-list :my-dialog nil))
  82.         (purgeable-res (getf init-list :purgeable NIL))
  83.         (locked-res (getf init-list :locked nil))
  84.         (id (getf init-list :pict-id :SCRAP))
  85.         (filename (getf init-list :my-filename nil)))
  86.     (and filename (setq filename (expand-logical-namestring filename)))
  87.     (have 'my-filename filename)
  88.     (unless dialog
  89.       (error "You must supply the dialog in :MY-DIALOG"))
  90.     ;; REGULAR HANDLES MUST NOT BE PURGEABLE, ELSE PICT IS LOST!
  91.     (setq purgeable-res (and (numberp id) purgeable-res))
  92.     (have 'my-pict-id id)            ; PICTURE RESOURCE ID OR WAITING FOR SCRAP
  93.     (have 'my-pict-handle nil)       ; HANDLE TO PICT RESOURCE OR JUST TO PICT IN MEMORY
  94.     (have 'resource-p (numberp id))  ; IS MY-PICT-HANDLE A HANDLE TO A RESOURCE?
  95.     (have 'zoom-factor nil)          ; HOW TO SCALE THE PICT FOR DRAWING
  96.     (have 'purgeable purgeable-res)  ; SHOULD RESOURCE BE PURGEABLE?
  97.     (have 'locked locked-res)        ; SHOULD RESOURCE BE LOCKED?
  98.     ;; TRY TO LOAD PICT FROM RESOURCE, IF NECESSARY
  99.     (load-pict purgeable-res locked-res)
  100.     (usual-exist init-list)
  101.     (have 'my-dialog dialog)         ; DIALOG TO WHICH PICT BELONGS (MUST BE SUPPLIED)
  102.     (zoom-by-factor (getf init-list :zoom-factor -1))))  ; INITIALIZE SCALE FACTOR NOW!
  103.  
  104.  
  105. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  106. ;;
  107. ;;load-pict
  108. ;;
  109. ;;   If there's a pict-id, it loads the PICT from the current resource map.
  110. ;;   Else, if there's a filename, then it loads the first PICT resource it sees
  111. ;;   in that file's resource map.
  112. ;;   Else, this dialog item must be waiting to be pasted onto from the scrap
  113. ;;   during a later (or ongoing) paste operation.
  114. ;;
  115. (defobfun (load-pict *pict-dialog-item*) (purgeable locked 
  116.                                                     &aux (found-handle nil)
  117.                                                     (curresfile (_curresfile :errchk :word)))
  118.   (declare (object-variable my-pict-id my-pict-handle resource-p))
  119.   (unwind-protect
  120.     (progn
  121.       (when my-filename
  122.         ;; OPEN PICT FROM RESOURCE FILE IF FILE ALREADY EXISTS:
  123.         (when (probe-file my-filename)
  124.           (unless (numberp my-pict-id)
  125.             (map-resources "PICT"
  126.                            #'(lambda (handle)
  127.                                (setq found-handle handle))
  128.                            :resource-filename my-filename
  129.                            :close-file nil
  130.                            :make-current t)
  131.             (if found-handle
  132.               (multiple-value-bind (res-type res-id res-name res-size)
  133.                                    (get-resource-info found-handle)
  134.                 (setq my-pict-id res-id))
  135.               (error "Could not find a PICT inside file ~a" my-filename)))))
  136.       ;; NOW GET THE PICTURE, IF NECESSARY:
  137.       (cond ((eq my-pict-id :scrap))
  138.             ((numberp my-pict-id)
  139.              (when (null (setq my-pict-handle (_getpicture :word my-pict-id :ptr)))
  140.                (error "PICT RESOURCE ID ~A NOT FOUND." my-pict-id))
  141.              (unless purgeable
  142.                (_hnopurge :errchk :A0 my-pict-handle :D0))
  143.              (when locked
  144.                (_hlock :errchk :A0 my-pict-handle)))
  145.             ((error ":PICT-ID must either be a number or :SCRAP; was ~s" my-pict-id))))
  146.     (_useresfile :errchk :word curresfile)
  147.     (_reserror :errchk)))
  148.  
  149.  
  150. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  151. ;;
  152. ;;start-drawing
  153. ;;
  154. ;;   Initiates drawing into this *pict-dialog-item*.  Any quickdraw commands
  155. ;;   drawn into the picture and terminated with a stop-drawing command
  156. ;;   will be recorded into this *pict-dialog-item* for later replay or
  157. ;;   simply to save it.
  158. ;;   The optional DRAW-ON-SCREEN parameter allows you to actually see what
  159. ;;   is being drawn into the *pict-dialog-item*, as long as it partially
  160. ;;   shows on the window in which it is being drawn.
  161. ;;
  162. ;;   Note: recording will be clipped by the size of this picture.  For
  163. ;;   your convenience, start-drawing optionally accepts a new size for the *pict-dialog-item*.
  164. ;;
  165. (defobfun (start-drawing *pict-dialog-item*) (&key left top right bottom 
  166.                                                    (draw-on-screen nil)
  167.                                                    &aux (me (self))
  168.                                                    (dialog my-dialog))
  169.   (unless my-filename (error "You should have associated a file with this drawing!"))
  170.   (when my-pict-handle (error "You already have a drawing stored in this picture!"))
  171.   (unless left
  172.     (let ((size (ask dialog (rref wptr :window.portrect))))
  173.       (setq left (rref size :rect.left)
  174.             top (rref size :rect.top)
  175.             right (rref size :rect.right)
  176.             bottom (rref size :rect.bottom))))
  177.   (if left
  178.     (unless (and top right bottom)
  179.       (error "Must supply ALL coordinates onto which to draw.")))
  180.   (ask me (set-dialog-item-size (make-point (abs (- right left)) (abs (- bottom top)))))
  181.   (ask dialog (start-picture left top right bottom))
  182.   (if draw-on-screen
  183.     (ask dialog (rset wptr :cgrafport.pnvis 0))))
  184.  
  185. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  186. ;;
  187. ;;stop-drawing
  188. ;;
  189. ;;   Stops drawing into this *pict-dialog-item*.  (See start-drawing.)
  190. ;;   Hereafter, this picture will display what you have recorded into it.
  191. ;;   You should supply the pathname to the file in which you want this
  192. ;;   resource saved.  If you don't supply one, then the resource will
  193. ;;   be saved into the currently open resource file.
  194. ;;
  195. (defobfun (stop-drawing *pict-dialog-item*) (&key (resource-name "")
  196.                                                   &aux (dialog (objvar my-dialog)))
  197.   (unless my-filename (error "You should have associated a file with this drawing!"))
  198.   (setq my-pict-handle (ask dialog (get-picture)))
  199.   (multiple-value-bind (type ID)
  200.                        (convert-handle-to-resource my-pict-handle "PICT"
  201.                                                    :filename my-filename
  202.                                                    :resource-name resource-name)
  203.     (setq my-pict-id ID
  204.           resource-p T))
  205.   (ask dialog (rset wptr :cgrafport.pnvis 0)))  ; MAKE SURE THAT WE CAN NOW DRAW INTO SCREEN
  206.   
  207.     
  208.  
  209. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  210. ;;
  211. ;;remove-self-from-dialog
  212. ;;
  213. ;;   Makes sure that the PICT is cleaned up.
  214. ;;
  215. (defobfun (remove-self-from-dialog *pict-dialog-item*) ()
  216.   (declare (object-variable my-pict-handle resource-p))
  217.   (when (handlep my-pict-handle)
  218.     (if resource-p
  219.       (_releaseresource :ptr my-pict-handle :word)
  220.       (_killpicture :errchk :ptr my-pict-handle))
  221.     (setq my-pict-handle nil))
  222.   ;;; CLOSE RESOURCE FILE, IF NECESSARY:
  223.   (let ((n (with-pstrs ((fn (expand-logical-namestring my-filename)))
  224.              (prog1 (_openresfile :errchk :ptr fn :word)
  225.                (_reserror :errchk)))))
  226.     (_closeresfile :errchk :word n)
  227.     (_reserror :errchk))
  228.   (usual-remove-self-from-dialog))
  229.  
  230. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  231. ;;
  232. ;;dialog-item-draw
  233. ;;
  234. ;; zoom-factor DETERMINES HOW THE PICT IS ZOOMED:
  235. ;;
  236. ;; zoom-factor = 0
  237. ;;          Draw PICT to fit visible window
  238. ;;;;;          Draw PICT from PICT resource size information,
  239. ;;;;;          starting at window origin
  240. ;; zoom-factor > 0
  241. ;;          Draw PICT starting at dialog-item-position,
  242. ;;          scale height and width from dialog-item-size
  243. ;;          multiplied by zoom-factor
  244. ;; zoom-factor < 0
  245. ;;          Draw PICT starting at dialog-item-position, 
  246. ;;          scale height and width from resource size
  247. ;;          information multiplied by absolute value of zoom-factor
  248. ;;          
  249. ;;         
  250. (defobfun (dialog-item-draw *pict-dialog-item*) ()
  251.   (declare (object-variable my-dialog my-pict-handle zoom-factor resource-p wptr purgeable
  252.                             CCL::dialog-item-position-iv CCL::dialog-item-size-iv))
  253.   (when (handlep my-pict-handle)
  254.     (let* ((dialog my-dialog)
  255.            (pict-handle my-pict-handle)
  256.            (topleft (dialog-item-position))
  257.            (size (dialog-item-size))
  258.            (bottomright (add-points topleft size))
  259.            (dwptr (if (ask dialog (boundp 'wptr))   ; TO GET AROUND MACL VIEW BUG IN 1.3.1
  260.                     (ask dialog wptr))))
  261.       (when dwptr
  262.         ;; RELOAD RESOURCE IF NECESSARY
  263.         (when (and resource-p
  264.                    purgeable
  265.                    (null (%get-ptr pict-handle)))
  266.           (_loadresource :errchk :ptr pict-handle))
  267.         ;; RECT ALLOCATED ON STACK, SO IT WON'T BUMP RESOURCE EVEN IF WE DON'T HAVE THE EXTRA WORD!
  268.         (rlet ((r :rect :topleft topleft :bottomright bottomright))
  269.           (with-port dwptr
  270.             (_DrawPicture :ptr pict-handle :ptr r)))))))
  271.  
  272. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  273. ;;
  274. ;;zoom-by-factor and zoom-factor
  275. ;;
  276. ;;   Use this accessors to zoom and to get the current zoom factor.
  277. ;;   The zoom allows you to respecify the upper-left hand corner
  278. ;;   to position and/or the size of the *pict-dialog-item*.
  279. ;;   You may optionally require the zoom to redraw the *pict-dialog-item*.
  280. ;;   The semantics of the zoom factor number are explained in
  281. ;;   the DIALOG-ITEM-DRAW object function for *pict-dialog-item*.
  282. ;;
  283.  
  284. (defobfun (zoom-factor *pict-dialog-item*) ()
  285.   (declare (object-variable zoom-factor))
  286.   zoom-factor)
  287.  
  288. (defobfun (zoom-by-factor *pict-dialog-item*) (factor &key redraw position size)
  289.   (declare (object-variable zoom-factor CCL::dialog-item-position-iv CCL::dialog-item-size-iv))
  290.   (unless (numberp factor)
  291.     (error "Scale factor must be a number"))
  292. ;;  (and (< factor 1) (> factor 0) (inval-dialog-item)) SHOULD BE DONE BY WINDOW
  293.   (setq zoom-factor factor
  294.         CCL::dialog-item-position-iv (or position (get-real-position))
  295.         CCL::dialog-item-size-iv (or size (get-real-size)))
  296.   (when redraw (dialog-item-draw)))
  297.  
  298.  
  299.  
  300.  
  301.  
  302.  
  303. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  304. ;;
  305. ;;get-real-size
  306. ;;
  307. ;;  The size of the *pict-dialog-item* may be the usual dialog item size
  308. ;;  or it may be based on the position and size information in the PICT
  309. ;;  resource, depending on the value of zoom-factor.  (See comments for
  310. ;;  DIALOG-ITEM-DRAW to understand the motivation for this.)
  311. ;;
  312. (defobfun (get-real-size *pict-dialog-item*) (&aux pict-size
  313.                                                    (dialog my-dialog))
  314.   (declare (object-variable zoom-factor my-pict-handle my-dialog
  315.                             resource-p purgeable))
  316.   (if (zerop zoom-factor)
  317.     ;; CALCULATE SIZE FROM WINDOW SIZE INFO:
  318.     (setq pict-size (ask dialog (window-size)))
  319.     (if (> zoom-factor 0)
  320.       ;; CALCULATE SIZE FROM DIALOG ITEM SIZE INFO:
  321.       (setq pict-size (dialog-item-size))
  322.       ;; CALCULATE SIZE FROM PICT RESOURCE SIZE INFO:
  323.       (let* ((pict-handle (progn
  324.                             (if (and resource-p
  325.                                      purgeable
  326.                                      (null (%get-ptr my-pict-handle)))
  327.                               (_loadresource :ptr my-pict-handle))
  328.                             my-pict-handle))
  329.              (topleft (rref pict-handle picture.picframe.topleft))
  330.              (bottomright (rref pict-handle picture.picframe.bottomright)))
  331.         (setq pict-size (subtract-points bottomright topleft)))))
  332.   (if (or (zerop zoom-factor)
  333.           (= zoom-factor 1))
  334.     pict-size  ; SCALING IS UNNECESSARY
  335.     (make-point (truncate (* (abs zoom-factor)
  336.                              (point-h pict-size)))
  337.                 (truncate (* (abs zoom-factor)
  338.                              (point-v pict-size))))))
  339.  
  340.  
  341. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  342. ;;
  343. ;;get-real-position
  344. ;;
  345. ;;  The position of the *pict-dialog-item* may be the usual dialog item position
  346. ;;  or it may be based on the position information in the PICT
  347. ;;  resource, depending on the value of zoom-factor.  (See comments for
  348. ;;  DIALOG-ITEM-DRAW to understand the motivation for this.)
  349. ;;
  350. (defobfun (get-real-position *pict-dialog-item*) ()
  351.   (declare (object-variable zoom-factor my-pict-handle resource-p purgeable))
  352.   (if (zerop zoom-factor)
  353.     ;; DIALOG ITEM STARTS AT TOPLEFT OF WINDOW
  354.     #@(0 0)
  355.     (if (> zoom-factor 0)
  356.       ;; DIALOG ITEM STARTS AT USUAL DIALOG ITEM POSITION
  357.       (dialog-item-position)
  358.       ;; DIALOG ITEM STARTS AT PICT RESOURCE TOPLEFT POSITION
  359.       (let ((pict-handle (progn
  360.                            (if (and resource-p
  361.                                     purgeable
  362.                                     (null (%get-ptr my-pict-handle)))
  363.                              (_loadresource :ptr my-pict-handle))
  364.                            my-pict-handle)))
  365.         (rref pict-handle picture.picframe.topleft)))))
  366.       
  367.  
  368.  
  369. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  370. ;;
  371. ;;dialog-item-click-event-handler
  372. ;;
  373. ;;  this function is called whenever the user clicks in the dialog item.  It
  374. ;;  is called on mouse-down, not on mouse-up.
  375. ;;
  376. ;;  the version defined below tracks the mouse, inverting the pict as long
  377. ;;  as the mouse is over it.  If the user releases the mouse-button while the
  378. ;;  the mouse is over the pict, the pict's dialog-item-action is called.
  379. ;;
  380. ;;
  381. (defobfun (dialog-item-click-event-handler *pict-dialog-item*) (where)
  382.   (declare (object-variable my-dialog zoom-factor wptr)
  383.            (ignore where))
  384.   (let* ((pos (dialog-item-position))
  385.          (size (dialog-item-size))
  386.          (mtop (point-v pos))
  387.          (mleft (point-h pos))
  388.          (mbottom (point-v (add-points pos size)))
  389.          (mright (point-h (add-points pos size)))
  390.          (inverted-p nil)
  391.          (item (self)))
  392.     (ask my-dialog
  393.       (with-port wptr
  394.         (rlet ((temp-rect :rect
  395.                           :top mtop
  396.                           :left mleft
  397.                           :bottom mbottom
  398.                           :right mright))
  399.           (without-interrupts
  400.            (_inverrect :ptr temp-rect)
  401.            (setq inverted-p t)
  402.            (loop
  403.              (unless (mouse-down-p)
  404.                (when inverted-p
  405.                  (ask item (dialog-item-action))
  406.                  (_inverrect :ptr temp-rect))
  407.                (return-from dialog-item-click-event-handler))
  408.              (if (logbitp 8 (_PtInRect
  409.                              :long (window-mouse-position)
  410.                              :ptr temp-rect
  411.                              :word))
  412.                (unless inverted-p
  413.                  (_inverrect :ptr temp-rect)
  414.                  (setq inverted-p t))
  415.                (when inverted-p
  416.                  (_inverrect :ptr temp-rect)
  417.                  (setq inverted-p nil))))))))))
  418.  
  419.  
  420. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  421. ;;
  422. ;;dialog-item-action
  423. ;;
  424. ;;  when the user releases the mouse with the cursor over the pict,
  425. ;;  dialog-item-click-event-handler leaves the pict highlighted and calls
  426. ;;  dialog-item-action.  For this reason, the usual-dialog-item-action
  427. ;;  redraws the pict to un-invert it.
  428. ;;
  429. ;;;(defobfun (dialog-item-action *pict-dialog-item*) ()
  430. ;;;  (usual-dialog-item-action))
  431.  
  432.  
  433.  
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  442. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  443. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  444. ;;
  445. ;;Scrap handling for *pict-dialog-item*
  446. ;;
  447. ;;    MACL's convention for scrap handler requires them to be instances
  448. ;;    of a class:  ugly... but who's perfect?
  449. ;;
  450. (defvar *pict-scrap-handler* (oneof *scrap-handler*))
  451.  
  452. (setq *scrap-handler-alist*
  453.       (nconc *scrap-handler-alist*
  454.              `((:PICT . ,*pict-scrap-handler*))))
  455.  
  456.  
  457. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  458. ;;
  459. ;;set-internal-scrap
  460. ;;
  461. ;;   Puts a PICT into the MACL private scrap, disposing of old one
  462. ;;   before overwriting it.  Uses pict-handle instead of internal-scrap ivar
  463. ;;   to avoid having a handle clobbered by Fred or text edit boxes.
  464. ;;   PICTs are handles to memory resources:  one cannot assume that the
  465. ;;   garbage collector will take care of it!
  466. ;;
  467. (defobfun (set-internal-scrap *pict-scrap-handler*) (new-scrap)
  468.   (declare (object-variable internal-scrap))
  469.   (let ((pict-handle internal-scrap))
  470.     (or (handlep new-scrap)
  471.         (null new-scrap)
  472.         (error "SCRAP ITEM ~S SHOULD BE A HANDLE OR NIL." new-scrap))
  473.     (and (handlep pict-handle)
  474.          (_killpicture :errchk :ptr pict-handle))
  475.     (usual-set-internal-scrap new-scrap)
  476.     (and new-scrap
  477.          (pushnew :PICT *scrap-state*))))
  478.  
  479. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  480. ;;
  481. ;;internalize-scrap
  482. ;;
  483. ;;   Copies a PICT from the public scrap into the MACL private scrap.
  484. ;;   When called, we already know that a PICT is waiting in the scrap.
  485. ;;   Also, set-internal-scrap will have been called with a NIL argument,
  486. ;;   forcing the old internal PICT to have been killed.
  487. ;;
  488. (defobfun (internalize-scrap *pict-scrap-handler*) (&aux pict-handle)
  489.   (declare (object-variable internal-scrap))
  490.   (setq pict-handle (_newhandle :errchk :D0 0 :A0))
  491.   (_GetScrap :ptr pict-handle :ostype :PICT :long  #xA78)
  492.   (setq internal-scrap pict-handle))
  493.  
  494.  
  495. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  496. ;;
  497. ;;get-internal-scrap
  498. ;;
  499. ;;   Gets the PICT resource from the private scrap.
  500. ;;
  501. (defobfun (get-internal-scrap *pict-scrap-handler*) ()
  502.   (declare (object-variable internal-scrap))
  503.   internal-scrap)
  504.  
  505.  
  506. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  507. ;;
  508. ;;externalize-scrap
  509. ;;
  510. ;;   Gets a PICT from the internal scrap and copies it into the public scrap.
  511. ;;   If memory is low, it tries its best in memory or does it on disk.
  512. ;;
  513. (defobfun (externalize-scrap *pict-scrap-handler*) ()
  514.   (declare (object-variable internal-scrap))
  515.   (labels ((put-pictscrap (size handle)
  516.                           (with-dereferenced-handles ((p handle))
  517.                             (_putscrap  :long size :ostype :PICT :ptr p :long))))
  518.     (let* ((pict-handle internal-scrap)
  519.            (pict-size (if (handlep pict-handle)
  520.                         251266 ; (rref pict-handle :picture.picsize) ;; was (- (_gethandlesize :a0 pict-handle :d0) 8)
  521.                         0))
  522.            (scrapptr (_infoscrap :long))
  523.            old-scrapsize
  524.            result)
  525.       (when (> pict-size 0)   ; A HANDLE WITH REAL CONTENTS TO EXTERNALIZE!
  526.         (_zeroscrap :errchk)
  527.         (cond ((rref scrapptr :scrapstuff.scraphandle)    ; SCRAP IS IN MEMORY
  528.                (setq old-scrapsize (rref scrapptr :scrapstuff.scrapsize)
  529.                      result (put-pictscrap pict-size pict-handle))
  530.                (when (\= result 0)   ; FAILED:  RESTORE OLD SCRAP AND TRY TO FIND MEMORY
  531.                  (rset scrapptr :scrapstuff.scrapsize old-scrapsize)
  532.                  (_sethandlesize :errchk
  533.                                  :A0 (rref scrapptr :scrapstuff.scraphandle)
  534.                                  :D0 old-scrapsize)
  535.                  (if (> (_maxmem :errchk :D0) pict-size)
  536.                    (setq result (put-pictscrap pict-size pict-handle)))
  537.                  (when (\= result 0)  ; FAILED AGAIN: RESTORE OLD SCRAP AND DO ON DISK
  538.                    (rset scrapptr :scrapstuff.scrapsize old-scrapsize)
  539.                    (_sethandlesize :errchk
  540.                                    :A0 (rref scrapptr :scrapstuff.scraphandle)
  541.                                    :D0 old-scrapsize)
  542.                    (_unlodescrap :errchk)  ; UNLOAD SCRAP TO DISK
  543.                    (put-pictscrap pict-size pict-handle))))
  544.               (t ; SCRAP IS ON DISK
  545.                (put-pictscrap pict-size pict-handle)))))))
  546.  
  547.  
  548. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  549. ;;
  550. ;;paste for *dialog* redefined!!!
  551. ;;
  552. ;;   Wherein *dialog* is taught to handle *pict-dialog-item*s.
  553. ;;   To be really general, there should be a cut, copy, and paste dispatcher
  554. ;;   for each scrap type which does the right thing: but doing this would require
  555. ;;   patching too much of the underlying MACL code.  So...
  556. ;;
  557. ;;   This overrides MACL's PASTE method for the *dialog* class.
  558. ;;
  559. (defobfun (paste *dialog*) ()
  560.   (if (memq :PICT *scrap-state*)
  561.     ; PASTING A PICT CREATES A *pict-dialog-item* INSTANCE IN THE DIALOG
  562.     (let* ((me (self))
  563.            (pict-di (oneof *pict-dialog-item* :my-dialog me)))
  564.       (add-dialog-items pict-di)
  565.       (ask pict-di (paste)))
  566.     (let ((cur (current-editable-text)))
  567.       (when cur (ask cur (paste))))))
  568.  
  569. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  570. ;;
  571. ;;copy for *dialog* NOT redefined!!!
  572. ;;
  573. ;;  Again, MACL doesn't have a general way of dealing with a selected dialog item.
  574. ;;  So, instead of mucking too much with the architecture and making future compatibility
  575. ;;  more difficult, we leave it alone for YOU to muck with!
  576. ;;
  577. ;(defobfun (copy *dialog*) ()
  578. ;  (let* ((cur (current-editable-text)))
  579. ;    (when cur (ask cur (copy)))))
  580.  
  581. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  582. ;;
  583. ;;cut for *dialog* NOT redefined!!!
  584. ;;
  585. ;;  Again, MACL doesn't have a general way of dealing with a selected dialog item.
  586. ;;  So, instead of mucking too much with the architecture and making future compatibility
  587. ;;  more difficult, we leave it alone for YOU to muck with!
  588. ;;
  589. ;;;(defobfun (cut *dialog*) ()
  590. ;;;  (let* ((cur (current-editable-text)))
  591. ;;;    (when cur (ask cur (cut)))))
  592.  
  593. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  594. ;;
  595. ;;clear for *dialog* NOT redefined!!!
  596. ;;
  597. ;;  Again, MACL doesn't have a general way of dealing with a selected dialog item.
  598. ;;  So, instead of mucking too much with the architecture and making future compatibility
  599. ;;  more difficult, we leave it alone for YOU to muck with!
  600. ;;
  601. ;;;(defobfun (clear *dialog*) ()
  602. ;;;  (let* ((cur (current-editable-text)))
  603. ;;;    (when cur (ask cur (clear)))))
  604.  
  605.  
  606.  
  607. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  608. ;;
  609. ;;paste for *pict-dialog-item*
  610. ;;
  611. ;;   Wherein *pict-dialog-item* paints itself from the scrap!
  612. ;;   This is dispatched by the *dialog*'s PASTE method.
  613. ;;
  614. (defobfun (paste *pict-dialog-item*) ()
  615.   (declare (object-variable my-pict-handle my-pict-id))
  616.   (when (handlep my-pict-handle)
  617.     (error "CAN'T PASTE INTO DIALOG ITEM ~a" (self)))       ; IN CASE IT'S ATTEMPTED!
  618.   (let ((pict (ask *pict-scrap-handler* (get-internal-scrap))))
  619.     (when (handlep pict)
  620.       (without-interrupts
  621.        (_hlock :errchk :A0 pict)
  622.        (setq my-pict-handle (_handtohand :errchk :A0 pict :A0))   ; GET A COPY
  623.        (_hnopurge :A0 my-pict-handle)
  624.        (setq my-pict-id nil)
  625.        ;; SCALE PICT TO ITS NATIVE SIZE STARTING AT HOME
  626.        (zoom-by-factor -1 :position #@(0 0))
  627.        (_hunlock :errchk :A0 pict))
  628.       (dialog-item-draw))))            ; NOW DRAW SELF
  629.  
  630.       
  631. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  632. ;;
  633. ;;copy for *pict-dialog-item*
  634. ;;
  635. ;;   Wherein *pict-dialog-item* copies itself to the scrap!
  636. ;;
  637. (defobfun (copy *pict-dialog-item*) ()
  638.   (declare (object-variable my-pict-handle))
  639.   (let ((pict-handle my-pict-handle))
  640.     (unless (handlep pict-handle)
  641.       (error "PICT DIALOG ITEM ~a DOES NOT CONTAIN A PICTURE." (self)))
  642.     (let (new-pict)
  643.       (_hlock :errchk :A0 pict-handle)
  644.       (setq new-pict (_handtohand :errchk :A0 pict-handle :A0))
  645.       (_hnopurge :A0 new-pict :D0)
  646.       (_hunlock :errchk :A0 pict-handle)
  647.       (put-scrap :PICT new-pict t))))       ; MAY NOT BE NECESSARY TO OVERWRITE...
  648.  
  649. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  650. ;;
  651. ;;clear for *pict-dialog-item*
  652. ;;
  653. ;;   Wherein *pict-dialog-item* clears itself
  654. ;;
  655.  
  656.  
  657. (provide ':pict-dialog-items)
  658. (pushnew ':pict-dialog-items *features*)
  659.  
  660.  
  661. #|  SAMPLES:
  662.  
  663. (defobject *our-color-dialog* *color-dialog*) ; MAKING IT CONVENIENT TO DISSECT WINDOW BY SUBCLASSING
  664.  
  665. ;;; TWO SAMPLES FOLLOW:
  666. ;;;   1. WE OPEN A RESOURCE FILE WITH PICT RESOURCES IN IT.  THEN, WE CREATE A
  667. ;;;      WINDOW & A *pict-dialog-item* INTO WHICH WE WILL PUT A PICT RESOURCE
  668. ;;;      FROM THE OPENED FILE.  THEN WE PLAY AROUND WITH IT.  WE FINALLY CUT
  669. ;;;      AND PASTE IT INTO ANOTHER PROGRAM.
  670. ;;;
  671. ;;;   2. WE CREATE A WINDOW & A *pict-dialog-item* WITHOUT ANY PICT RESOURCE
  672. ;;;      ASSOCIATED WITH IT.  WE START RECORDING DRAWING CALLS INTO IT.
  673. ;;;      WE PLAY WITH IT AFTER WE STOP RECORDING.  THEN WE CLOSE THE WINDOW
  674. ;;;      AND RELOAD THE RECORDED PICTURE FROM A FILE INTO WHICH WE SAVED IT.
  675. ;;;
  676.  
  677. ;;; 1. PLAYING WITH A PICTURE FROM AN EXISTING PICTURE RESOURCE FILE:
  678.  
  679. (open-resource-file "macframes;frameset-kernel:allegro:navigator:PICT")
  680.  
  681. (let ((a-dialog (oneof *our-color-dialog*
  682.                        :window-size #@(400 400)
  683.                        :window-title "PICTs"
  684.                        :window-position #@(40 40)
  685.                        :window-type :document-with-zoom)
  686.                 ))
  687.   (ask a-dialog
  688.     (add-dialog-items
  689.      (oneof *pict-dialog-item*
  690.             :my-dialog a-dialog
  691.             :pict-id 69
  692.             :purgeable T
  693.             :zoom-factor 0
  694.             :dialog-item-position #@(10 10)
  695.             :dialog-item-size #@(200 200)
  696.             :dialog-item-action '(progn
  697.                                    (format t "YOU ARE LOOKING AT PICT ID ~a." (objvar my-pict-id))
  698.                                    (ed-beep)
  699.                                    (usual-dialog-item-action))))))
  700.  
  701. ;;; GET THE WINDOW AND *PICT-DIALOG-ITEM*:
  702. (setq w (car (windows *our-color-dialog*)))
  703. (setq d (car (ask w (dialog-items))))
  704. ;;; CHECK IT OUT:
  705. (ask d (zoom-factor))
  706. (point-string (ask d (get-real-size)))
  707. (point-string (ask d (get-real-position)))
  708. (point-string (ask d (dialog-item-position)))
  709. (point-string (ask d (dialog-item-size)))
  710. ;;; PLAY WITH IT:
  711. (ask d (zoom-by-factor 0 :redraw t))
  712. (ask d (dialog-item-draw))
  713. (ask d (set-dialog-item-size #@(100 100)))
  714. (ask D (set-dialog-item-position #@(100 200)))
  715. (ask D (set-dialog-item-size #@(50 50)))
  716. ;;; COPY IT INTO THE CLIPBOARD:
  717. (ask d (copy))
  718. ;;; NOW GO TO A PAINT PROGRAM (e.g., Studio 8) IN MULTIFINDER AND DO A PASTE.
  719. ;;; THE PICTURE YOU JUST COPIED FROM ALLEGRO SHOULD HAVE BEEN
  720. ;;; PASTED INTO THE WINDOW IN YOUR PAINT PROGRAM.
  721.  
  722.  
  723.  
  724.  
  725.  
  726.  
  727. ;;; TESTING DRAWING INTO A *PICT-DIALOG-ITEM* AND SAVING IT IN A RESOURCE FILE.
  728.  
  729. ;;; THIS CREATES A DIALOG WINDOW WHICH WE'LL USE:
  730. (setq our-dialog (oneof *our-color-dialog*
  731.                         :window-title "Recording A Drawing Demo"
  732.                         :window-size (make-point (- *screen-width* 40) (- *screen-height* 40))
  733.                         :window-position (make-point 40 40)))
  734.  
  735. ;;; THIS CREATES A PICTURE DIALOG ITEM WHICH WE'LL INSERT INTO THE WINDOW:
  736. (setq our-drawing (oneof *pict-dialog-item*
  737.                          :my-filename "ccl;Demo-File-With-Drawing"
  738.                          :my-dialog our-dialog
  739.                          :pict-id :scrap
  740.                          :zoom-factor 0
  741.                          :dialog-item-position #@(0 0)
  742.                          :dialog-item-size (ask our-dialog (window-size))
  743.                          :dialog-item-action
  744.                          '(progn
  745.                             (ed-beep)
  746.                             (format t "~%You are at (~a,~a)."
  747.                                     (point-h (ask (objvar my-dialog) (window-mouse-position)))
  748.                                     (point-v (ask (objvar my-dialog) (window-mouse-position)))))))
  749.  
  750. ;;; WE INSERT OUR DIALOG ITEM INTO OUR WINDOW:
  751. (ask our-dialog (add-dialog-items our-drawing))
  752.  
  753. ;;; WE COMMAND IT TO START RECORDING OUR SUBSEQUENT DRAWING COMMANDS.
  754. ;;; WE TELL IT THAT WE WANT TO SEE WHAT WE ARE DRAWING:
  755. (ask our-drawing (start-drawing :draw-on-screen T))
  756.  
  757. ;;; LET'S DRAW SOMETHING INTO THE DIALOG WINDOW: [THIS IS BEING RECORDED AS WE DRAW IT]
  758. (ask our-dialog (frame-rect 100 100 200 200))
  759. (ask our-dialog (frame-rect 110 110 190 190))
  760. (ask our-dialog (frame-rect 120 120 180 180))
  761. (ask our-dialog (frame-rect 130 130 170 170))
  762. (ask our-dialog (paint-rect 140 140 160 160))
  763.  
  764. ;;; STOP RECORDING WHAT WE'RE DRAWING:
  765. (ask our-drawing (stop-drawing :resource-name "My Drawing"))
  766.  
  767. ;;; CHECK WHETHER DRAWING WAS ACTUALLY SAVED TO A FILE (ELSE, THERE WAS SOME PROBLEM):
  768. (let ((filename (ask our-drawing my-filename)))
  769.   (if (probe-file filename)
  770.     (format t "~%Great!  The drawing is saved in file ~s" filename)
  771.     (error "The drawing file ~s somehow was not created!" filename)))
  772.  
  773. ;;; LET'S PLAY WITH OUR DRAWING IN OUR WINDOW:
  774. (ask our-drawing (set-dialog-item-size (make-point 200 200)))  ; CHANGE ITS SIZE
  775. (ask our-drawing (zoom-by-factor 0 :redraw T))  ; MAKE IT ZOOM TO FIT OUR WINDOW
  776. (ask our-drawing (zoom-by-factor 1.5 :redraw T))  ; MAKE IT ZOOM TO BE BIGGER BY 1/2 THAN OUR WINDOW
  777. (ask our-drawing (set-dialog-item-position (make-point -100 -100)))  ; MOVE IT
  778. (ask our-drawing (set-dialog-item-position (make-point -100 100)))  ; MOVE IT
  779.  
  780. ;;; LET'S NOW GET RID OF OUR WINDOW:
  781. (ask our-dialog (window-close))
  782.  
  783. ;;; LET'S OPEN OUR DRAWING INTO A NEW WINDOW:
  784. (setq our-dialog (oneof *our-color-dialog*
  785.                         :window-title "Drawing A Recorded Drawing Demo"
  786.                         :window-size (make-point (- *screen-width* 40) (- *screen-height* 40))
  787.                         :window-position (make-point 40 40)))
  788.  
  789. ;;; THIS CREATES A PICTURE DIALOG ITEM WHICH WE'LL INSERT INTO THE WINDOW:
  790. (setq our-drawing (oneof *pict-dialog-item*
  791.                          :my-filename "ccl;Demo-File-With-Drawing"
  792.                          :my-dialog our-dialog
  793.                          :pict-id :scrap
  794.                          :zoom-factor 0
  795. ;                         :dialog-item-position #@(0 0)
  796. ;                         :dialog-item-size (ask our-dialog (window-size))
  797.                          :dialog-item-action
  798.                          '(progn
  799.                             (ed-beep)
  800.                             (format t "~%You are at (~a,~a)."
  801.                                     (point-h (ask (objvar my-dialog) (window-mouse-position)))
  802.                                     (point-v (ask (objvar my-dialog) (window-mouse-position)))))))
  803.  
  804.  
  805. ;;; WE INSERT OUR DIALOG ITEM INTO OUR WINDOW:
  806. (ask our-dialog (add-dialog-items our-drawing))
  807.  
  808. ;;; THE DRAWING SHOULD BE DISPLAYING IN OUR WINDOW.
  809.  
  810. ;;; DELETE YOUR DRAWING FILE, IF YOU WANT:
  811. (ask our-dialog (window-close))     ; THIS WILL CLOSE OUR WINDOW & YOUR DRAWING FILE
  812. (delete-file "ccl;Demo-File-With-Drawing")  ; THIS WILL DELETE IT
  813.  
  814. |#
  815.  
  816.  
  817.